perm filename MODEL.SAI[SYS,HE] blob
sn#004145 filedate 1972-06-08 generic text, type T, neo UTF8
00100 BEGIN "MODEL"
00200 REQUIRE 100 PNAMES;
00300 REQUIRE "PREAMB.SAI[SYS,HE]" SOURCE_FILE;
00400 REQUIRE 1000 NEW_ITEMS;
00500 REQUIRE "DPYSUB.HDR[SYS,HE]" SOURCE_FILE;
00600 REQUIRE "VECTOR.SAI" SOURCE_FILE;
00700 REQUIRE "SAILIB.REL" LOAD_MODULE;
00800 DEFINE $="GLOBAL";
00900 DEFINE ASSIGN="MATCH←FALSE;FOREACH";
01000 DEFINE HOLDS="DO IF MATCH THEN USERERR(0,0,""ASSIGN MULTIPLY DEFINED"")
01100 ELSE MATCH←TRUE;IF ¬MATCH THEN USERERR(0,0,""ASSIGN FAILS"")";
01200 BOOLEAN MATCH;
01300 SET DIRECTORY,INSTANCES,AXES,FOOPED,LEDGES,ATTRIBUTES;
01400 SET NOUSE,LSCENE;
01500 internal integer array ps[1:6];
01600 DEFINE ROLL="17",PITCH="18",YAW="19",DISTANCE="20",FOCUS="21",LLINE="6";
01700 DEFINE SDISP="1",PDISP="2";
01800 INTEGER ITEMVAR QPROT,QPARK,QMOVE,QINSTANCE,QDEFINE,QUOTE_INSTANCES,QPROTOTYPES,QW,QSOURCE,QE,D,AXIS;
01900 INTEGER ITEMVAR QROTATE;
02000 INTEGER ITEMVAR OBSERVER,QDELETE,QTRANSF;
02100 LABEL DE1,TL1,D0,L0,L1,L2,L3,L4,L5,L6;
02200 LABEL LS;
02300 ITEM TWO;
02400 LABEL LD1,D1,D2,LS1,LS2,LR1,LC1,LC2;
02500 ITEMVAR P,QF,QV;
02600 STRING RF,S;
02700 SAFE REAL ARRAY A,TT,INV,T[1:4,1:4],PVV,TTV,TV1,TV2,SV,V[1:4];
02800 SAFE REAL ARRAY ORIGN,XAXIS,YAXIS,ZAXIS[1:4];
02900 REAL ARRAY ITEMVAR NH,NT,NR,INST,CURRENT,R,F,TA,H,N,LT;
03000 PRELOAD_WITH [4] 0.0;
03100 SAFE REAL ARRAY ZERO[1:4];
03200 INTEGER OFS;
03300 PRELOAD_WITH [16] 0.0, -8.0, 5.0, -61.0, 60.0, 20.0,
03400 [16] 0.0, -8.0, 5.0, -61.0, 90.0, 13.0;
03500 SAFE REAL ARRAY PDATA[1:42];
03600 SAFE REAL ARRAY PTT,PT1[1:4,1:4];
03700 SAFE INTEGER ARRAY PDAT[1:50],SDAT[1:250];
03800 REAL DEG,COSV,SINV,DIST;
03900 REAL ARRAY ITEMVAR ARRAY VER,REG[1:20];
04000 ITEM FRONT,BEFORE,FOOP;
04100 ITEMVAR AT,OB,VAL;
04200 REAL ITEMVAR NE,E;
04300 INTEGER FILE,BREAK,EOF,PN,PV,I,J;
04400 BOOLEAN FIRSTIME;
04500 INTEGER ITEM TWIST,X,Y,Z,TRANSLATE,STRETCH;
04600 DEFINE TYPE="OUT(TTY,";
04700 DEFINE STAR="&""
04800 *"")";
04900 DEFINE LARROW="&""+"")";
05000 DEFINE EOM="&""
05100 "")";
05200 ITEM NEXTSYM;
05300 SAFE STRING ARRAY PNAME[0:1024];SAFE INTEGER ARRAY HASHTAB[0:511];
05400 DEFINE TTY="1";
05500 DEFINE FIRST1="8",ID="7";
05600 DEFINE GETS="S←INPUT(FILE,FIRST1);S←INPUT(FILE,ID);OUT(2,"" ""&S)";
05700
05800 SIMPLE PROCEDURE AXISOUT;
05900 BEGIN SAFE OWN REAL ARRAY TV1,TV2,TV3[1:4];
06000 EXTERNAL SIMPLE PROCEDURE TRANSFORM(REAL ARRAY R;REFERENCE REAL T;REAL ARRAY V);
06100 TRANSFORM(TV3,PDATA[OFS+1],YAXIS);
06200 REDUCE(TV3);
06300 TRANSFORM(TV1,PDATA[OFS+1],ORIGN);
06400 REDUCE(TV1);
06500 AIVECT(-TV1[2],-TV1[3]);
06600 TRANSFORM(TV2,PDATA[OFS+1],XAXIS);
06700 REDUCE(TV2);
06800 RVECT(TV1[2]-TV2[2],TV1[3]-TV2[3]);
06900 DPYSST("X");
07000 AIVECT(-TV3[2],-TV3[3]);
07100 DPYSST("Y");
07200 AIVECT(-TV3[2],-TV3[3]);
07300 RVECT(TV3[2]-TV1[2],TV3[3]-TV1[3]);
07400 TRANSFORM(TV2,PDATA[OFS+1],ZAXIS);
07500 REDUCE(TV2);
07600 RVECT(TV1[2]-TV2[2],TV1[3]-TV2[3]);
07700 DPYSST("Z");
07800 END;
00100
00200 INTEGER SIMPLE PROCEDURE CVFN(ITEM X);
00300 BEGIN INTEGER I;
00400 RETURN(IF (I←CVN(X))>1024 THEN I-3071 ELSE I);
00500 END;
00600
00700 SIMPLE PROCEDURE HASHINDEX (STRING S;REFERENCE INTEGER I);
00800 BEGIN EXTERNAL INTEGER SIMPLE PROCEDURE HASH (STRING S);
00900 EXTERNAL INTEGER SIMPLE PROCEDURE REHASH;
01000 INTEGER HOLE,PTR;
01100 HOLE←0;
01200 I←HASH(S);
01300 WHILE (PTR←HASHTAB[I])DO BEGIN
01400 IF PTR>1024 THEN PTR←PTR-3071;
01500 IF PTR<0 THEN HOLE←I ELSE
01600 IF EQU(PNAME[PTR],S) THEN RETURN;
01700 I←REHASH;
01800 END;
01900 IF HOLE THEN I←HOLE;
02000 END;
02100
02200 ITEMVAR SIMPLE PROCEDURE READ;
02300 BEGIN ITEMVAR X;
02400 INTEGER I;
02500 STRING S;
02600 LABEL LR1,LR2;
02700 LR1: S←INPUT(FILE,FIRST1);S←INPUT(FILE,ID);
02800 IF EOF≠0 THEN BEGIN RELEASE(4);FILE←1;GOTO LR1 END;
02900 HASHINDEX (S,I);
03000 IF HASHTAB[I]>0 THEN BEGIN
03100 X←CVI(HASHTAB[I]);
03200 GO TO LR2 END;
03300 X←NEW;
03400 HASHTAB[I]←CVN(X);
03500 PNAME[CVFN(X)]←S;
03600 LR2: IF ¬(X IN NOUSE) THEN OUT(2," "&S);
03700 RETURN(X)
03800 END;
03900
04000 ITEMVAR SIMPLE PROCEDURE GREAD;
04100 BEGIN ITEMVAR X;
04200 INTEGER I,F;
04300 STRING S;
04400 LABEL LR1,LR2;
04500 LR1: S←INPUT(FILE,FIRST1);S←INPUT(FILE,ID);
04600 IF EOF≠0 THEN BEGIN RELEASE(4);FILE←1;GOTO LR1 END;
04700 HASHINDEX (S,I);
04800 IF HASHTAB[I]>0 THEN BEGIN
04900 X←CVI(HASHTAB[I]);
05000 GO TO LR2 END;
05100 X←CVSI(S,F);
05200 IF F THEN X←$ NEW;
05300 HASHTAB[I]←CVN(X);
05400 PNAME[CVFN(X)]←S;
05500 LR2: IF ¬(X IN NOUSE) THEN OUT(2," "&S);
05600 RETURN(X)
05700 END;
05800
05900 REAL ARRAY ITEMVAR PROCEDURE GREADA(REAL ARRAY A);
06000 BEGIN REAL ARRAY ITEMVAR X;
06100 INTEGER I,F;
06200 STRING S;
06300 GETS;
06400 HASHINDEX (S,I);
06500 IF HASHTAB[I]>0 THEN RETURN(CVI(HASHTAB[I]));
06600 X←CVSI(S,F);
06700 IF F THEN X←$ NEW(A);
06800 HASHTAB[I]←CVN(X);
06900 PNAME[CVFN(X)]←S;
07000 RETURN(X)
07100 END;
07200
07300 ITEMVAR SIMPLE PROCEDURE INTERN(STRING S);
07400 BEGIN ITEMVAR X;
07500 INTEGER I;
07600 HASHINDEX (S,I);
07700 IF HASHTAB[I]>0 THEN RETURN(CVI(HASHTAB[I]));
07800 X←NEW;
07900 HASHTAB[I]←CVN(X);
08000 PNAME[CVFN(X)]←S;
08100 RETURN(X)
08200 END;
08300
08400 ITEMVAR SIMPLE PROCEDURE GINTERN(STRING S);
08500 BEGIN ITEMVAR X;
08600 INTEGER F,I;
08700 HASHINDEX (S,I);
08800 IF HASHTAB[I]>0 THEN RETURN(CVI(HASHTAB[I]));
08900 X←CVSI(S,F);
09000 IF F THEN X←$ NEW;
09100 HASHTAB[I]←CVN(X);
09200 PNAME[CVFN(X)]←S;
09300 RETURN(X)
09400 END;
09500
09600 REAL ITEMVAR PROCEDURE GINTERNS(STRING S;REAL V);
09700 BEGIN REAL ITEMVAR X;
09800 INTEGER I;
09900 HASHINDEX (S,I);
10000 IF HASHTAB[I]>0 THEN RETURN(CVI(HASHTAB[I]));
10100 X←$ NEW(V);
10200 HASHTAB[I]←CVN(X);
10300 PNAME[CVFN(X)]←S;
10400 RETURN(X)
10500 END;
10600
10700 REAL ITEMVAR PROCEDURE INTERNI(STRING S;INTEGER K);
10800 BEGIN INTEGER ITEMVAR X;
10900 INTEGER I;
11000 HASHINDEX (S,I);
11100 IF HASHTAB[I]>0 THEN RETURN(CVI(HASHTAB[I]));
11200 X←NEW(K);
11300 HASHTAB[I]←CVN(X);
11400 PNAME[CVFN(X)]←S;
11500 RETURN(X)
11600 END;
11700
11800 REAL ARRAY ITEMVAR PROCEDURE GINTERNA(STRING S;REAL ARRAY A);
11900 BEGIN REAL ARRAY ITEMVAR X;
12000 INTEGER I;
12100 HASHINDEX (S,I);
12200 IF HASHTAB[I]>0 THEN RETURN(CVI(HASHTAB[I]));
12300 X←$ NEW(A);
12400 HASHTAB[I]←CVN(X);
12500 PNAME[CVFN(X)]←S;
12600 RETURN(X)
12700 END;
12800
12900
13000 SIMPLE PROCEDURE INTERNITEM(ITEMVAR X);
13100 BEGIN STRING S;INTEGER I,P;
13200 S←CVIS(X,I);
13300 IF I≠0 THEN USERERR(0,1,"INTERNITEM: ITEM NOT COMPILED");
13400 HASHINDEX (S,I);
13500 P←CVN(X);
13600 COMMENT TYPE CVS(P) EOM;
13700 HASHTAB[I]←P;
13800 PNAME[CVFN(X)]←S
13900 END;
14000
14100 SIMPLE PROCEDURE GINTERNITEM(ITEMVAR X;STRING S);
14200 BEGIN INTEGER I,P;
14300 HASHINDEX (S,I);
14400 P←CVN(X);
14500 COMMENT TYPE CVS(P) EOM;
14600 IF HASHTAB[I]=0 THEN HASHTAB[I]←P;
14700 PNAME[CVFN(X)]←S
14800 END;
14900
15000 STRING SIMPLE PROCEDURE PRINTNAME(ITEMVAR X);RETURN(PNAME[CVFN(X)]);
15100
15200 STRING SIMPLE PROCEDURE GENSYM (ITEMVAR X);
15300 BEGIN STRING S;
15400 INTEGER ITEMVAR Y;
15500 LABEL L1;
15600 S←PRINTNAME(X);
15700 FOREACH Y | NEXTSYM ⊗ X ≡ Y DO GO TO L1;
15800 Y←NEW(0);
15900 MAKE NEXTSYM ⊗ X ≡ Y;
16000 L1: DATUM(Y)←DATUM(Y)+1;
16100 SETFORMAT(0,0);
16200 S←S&CVS(DATUM(Y));
16300 SETFORMAT (0,8);
16400 RETURN (S);
16500 END;
16600 EXTERNAL SIMPLE PROCEDURE INVERSION(REAL ARRAY A,B);
16700 REAL ARRAY ITEMVAR PROCEDURE NREG;
16800 BEGIN INTEGER I;
16900 REAL ARRAY ITEMVAR R;
17000 I←INTIN(FILE);
17100 OUT(2," "&CVS(I));
17200 IF I=999 THEN RETURN(NIL);
17300 IF REG[I]=NIL THEN
17400 BEGIN R←GINTERNA(GENSYM(QF),V);
17500 REG[I]←R END ELSE R←REG[I];
17600 RETURN (R) END;
17700 REAL ARRAY ITEMVAR PROCEDURE NVER;
17800 BEGIN INTEGER I;
17900 REAL ARRAY ITEMVAR R;
18000 I←INTIN(FILE);
18100 OUT(2," "&CVS(I));
18200 IF I=999 THEN RETURN (NIL);
18300 IF VER[I]=NIL THEN
18400 BEGIN R←GINTERNA(GENSYM(QV),V);
18500 VER[I]←R END ELSE R←VER[I];
18600 RETURN (R) END;
18700
18800 SIMPLE PROCEDURE GREMOB(ITEMVAR X);
18900 BEGIN
19000 INTEGER I;
19100 HASHINDEX(PNAME[CVFN(X)],I);
19200 IF HASHTAB[I]=0 THEN TYPE PNAME[CVFN(X)]&CVS(I) EOM;
19300 PNAME[CVFN(X)]←NULL;
19400 HASHTAB[I]←-1;
19500 $ DELETE(X) END;
19600
19700 PROCEDURE DISP (ITEMVAR P;REAL ARRAY RT;STRING S);
19800 BEGIN REAL ARRAY ITEMVAR H,F,NH,T,NT;
19900 SAFE OWN REAL ARRAY INVT,INV[1:4,1:4],TTV [1:4];
20000 SET SIDES,PRINTED;
20100 ITEMVAR N,E;
20200 INVERSION(INV,RT);
20300 FOR I ←1 STEP 1 UNTIL 4 DO
20400 FOR J←1 STEP 1 UNTIL 4 DO
20500 INVT[J,I]←INV[I,J];
20600 FOREACH H| $ VERTEX⊗P≡H DO BEGIN
20700 TRANSFORM (TTV ,RT,$ DATUM (H));
20800 REDUCE(TTV);
20900 T←NEW (TTV);
21000 MAKE TWO ⊗H≡T END;
21100 PRINTED←PHI;
21200 FOREACH F|$ FACE⊗P≡F DO BEGIN
21300 LABEL L2,L1;
21400 TRANSFORM(TTV,INVT,$ DATUM(F));
21500 IF TTV[1]>0.0 THEN GO TO L1;
21600 SIDES←($ BOUNDARY⊗F);
21700 E←LOP(SIDES);
21800 FOREACH H,T,NH,NT|$ ENDPT⊗E≡H ∧ $ ENDPT⊗E≡T ∧ (H≠T) ∧
21900 TWO⊗H≡NH ∧ TWO⊗T≡NT DO BEGIN
22000 AIVECT(-DATUM(NH)[2],-DATUM(NH)[3]);
22100 IF E IN PRINTED THEN
22200 RIVECT(DATUM(NH)[2]-DATUM(NT)[2],DATUM(NH)[3]-DATUM(NT)[3]) ELSE
22300 RVECT(DATUM(NH)[2]-DATUM(NT)[2],DATUM(NH)[3]-DATUM(NT)[3]);
22400 PUT E IN PRINTED;
22500 DONE END;
22600 L2: FOREACH H,E,NH,NT|E IN SIDES ∧$ ENDPT⊗E≡T ∧$ ENDPT⊗E≡H ∧( H≠T) ∧
22700 TWO⊗H≡NH ∧TWO⊗T≡NT DO BEGIN
22800 IF E IN PRINTED THEN
22900 RIVECT(DATUM(NT)[2]-DATUM(NH)[2],DATUM(NT)[3]-DATUM(NH)[3]) ELSE
23000 RVECT(DATUM(NT)[2]-DATUM(NH)[2],DATUM(NT)[3]-DATUM(NH)[3]);
23100 REMOVE E FROM SIDES;
23200 PUT E IN PRINTED;
23300 T←H; GO TO L2 END;
23400 L1: END;
23500 DPYSST(S);
23600 FOREACH H,NH| TWO⊗H≡NH DO BEGIN
23700 ERASE TWO⊗H≡NH;
23800 DELETE (NH) END END;
23900 SIMPLE PROCEDURE QUERY(REFERENCE REAL R;STRING N);
24000 BEGIN STRING S;
24100 REAL T;
24200 INTEGER I;
24300 OUT(TTY,N&" "&CVG(R)&"
24400 ");
24500 S←INPUT(FILE,LLINE);
24600 OUT(2,S);
24700 T←REALSCAN(S,I);
24800 R←IF I=-1 THEN R ELSE T END;
00100 OPEN(TTY,"TTY",0,2,2,120,BREAK,EOF);
00200 BREAKSET (LLINE,'12,"I");BREAKSET(LLINE,NULL,"A");BREAKSET(LLINE,NULL,"N");
00300 BREAKSET(FIRST1,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","I");
00400 BREAKSET (FIRST1,NULL,"R");
00500 BREAKSET (FIRST1,NULL,"N");
00600 BREAKSET(ID,"ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789","X");
00700 BREAKSET (ID,NULL,"N");
00800 BREAKSET(ID,NULL,"R");
00900 SETFORMAT(0,8);
01000 UNDERFLOW(TRUE);
01100 QINSTANCE←INTERNI("INSTANCE",0);
01200 QMOVE←INTERNI("MOVE",14);
01300 QPARK←INTERNI("PARK",15);
01400 QE←INTERNI("E",5);
01500 QSOURCE←INTERNI("SOURCE",6);
01600 QROTATE←INTERNI("ROTATE",1);
01700 DATUM(TWIST)←16;
01800 DATUM(TRANSLATE)←2;
01900 DATUM(STRETCH)←3;
02000 QDEFINE←INTERNI("DEFINE",4);
02100 QPROT←INTERNI("PROTOTYPE",10);
02200 QW←INTERNI("W",7);
02300 QUOTE_INSTANCES←INTERNI("INSTANCES",12);
02400 QPROTOTYPES←INTERNI("PROTOTYPES",8);
02500 QDELETE←INTERNI("DELETE",9);
02600 QTRANSF←INTERNI("TRANSFORM",11);
02700 OBSERVER←INTERNI("OBSERVER",13);
02800 DIRECTORY←{TWIST,QPARK,QW,QSOURCE,QE,QMOVE,QINSTANCE,QROTATE,TRANSLATE,STRETCH,QDEFINE,
02900 QTRANSF,OBSERVER,QPROT,QDELETE,QUOTE_INSTANCES,QPROTOTYPES};
03000 ATTRIBUTES←{INSTANCE,BEFORE,FACE,BOUNDARY,ENDPT,VERTEX,EDGE,CORNER⎇;
03100 NOUSE←{QSOURCE,QW,QE,QUOTE_INSTANCES,QPROTOTYPES};
03200 INTERNITEM(BEFORE);
03300 INTERNITEM(TWIST);
03400 INTERNITEM(TRANSLATE);
03500 INTERNITEM(STRETCH);
03600 INTERNITEM(FOOP);
03700 GINTERNITEM(TEST_BLOCK,"NEW");
03800 INTERNITEM(X);
03900 INTERNITEM(Y);
04000 INTERNITEM(Z);
04100 DATUM(X)←0;
04200 DATUM(Y)←1;
04300 DATUM(Z)←2;
04400 AXES←{X,Y,Z⎇;
04500 OPEN(2,"DSK",0,0,2,128,BREAK,EOF);
04600 OPEN(5,"DSK",0,2,0,128,BREAK,EOF);
04700 D2: TYPE "RECORD FILE NAME" STAR;
04800 RF←INPUT(TTY,FIRST1);
04900 RF←INPUT(TTY,ID);
05000 RF←RF&".REC";
05100 LOOKUP(5,RF,EOF);
05200 IF EOF =0 THEN BEGIN TYPE "FILE ALREADY EXISTS, DELETE Y OR N ?" STAR;
05300 S←INPUT(TTY,FIRST1);S←INPUT(TTY,ID);
05400 IF EQU (S,"Y") THEN CLOSE(5) ELSE GO TO D2 END;
05500 ENTER(2,RF,EOF);
05600 QF←INTERN("F");
05700 QV←INTERN("V");
05800 FILE←1;
05900 INSTANCES←PROTOTYPES←PHI;
06000 CURRENT←NIL;
06100 OFS←0;
06200 DPYSET(PDAT);
06300 DPYBRT(3);
06400 IDENTITY(PDATA);
06500 ARRBLT(PDATA[22],PDATA[1],16);
06600 IDENTITY($ DATUM(TEST_BLOCK));
06700 ORIGN[1]←ORIGN[2]←ORIGN[3]←0.0;ORIGN[4]←1.0;
06800 XAXIS[1]←8.0;XAXIS[2]←XAXIS[3]←0.0;XAXIS[4]←1.0;
06900 YAXIS[1]←YAXIS[3]←0.0;YAXIS[2]←8.0;YAXIS[4]←1.0;
07000 ZAXIS[1]←ZAXIS[2]←0.0;ZAXIS[3]←8.0;ZAXIS[4]←1.0;
07100 FOREACH P|$ PROTOTYPE ⊗ SCENE ≡ P DO
07200 BEGIN
07300 PUT P IN PROTOTYPES;
07400 INTERNITEM(P);
07500 END;
07600
00100 TYPE NULL STAR;
00200 D0: D←READ;
00300 IF ¬(D IN DIRECTORY) THEN BEGIN TYPE "UNDEFINED COMMAND "&PRINTNAME(D) STAR; GO TO D0 END;
00400 CASE DATUM(D) OF BEGIN
00500 BEGIN "INSTANCE"
00600 LABEL L1;
00700 P←READ;
00800 IF P IN INSTANCES THEN BEGIN CURRENT←P; GO TO L1 END;
00900 IF¬(P IN PROTOTYPES)THEN BEGIN TYPE "UNDEFINED PROTOTYPE "&PRINTNAME(P) STAR; GO TO D0 END;
01000 IDENTITY(T);
01100 OFS←0;
01200 INST←GREADA(T);
01300 FOR I←1 STEP 1 UNTIL 3 DO IF $ DATUM(INST)[I,4]≠0 THEN OFS←21;
01400 PUT INST IN INSTANCES;
01500 $ MAKE INSTANCE⊗P≡INST;
01600 HYDPOG(SDISP);
01700 CURRENT←INST;
01800 L1: IF OFS≠0 THEN GO TO LS
01900 END "INSTANCE";
02000 BEGIN "ROTATE"
02100 IF ¬(CURRENT IN INSTANCES) THEN BEGIN TYPE"NO INSTANCE SPECIFIED" STAR;GO TO D0 END;
02200 AXIS←READ;
02300 IF ¬(AXIS IN AXES) THEN BEGIN TYPE "MISSING ROTATION AXIS"STAR;GO TO D0 END;
02400 DEG←REALIN(FILE);
02500 OUT(2,CVG(DEG));
02600 IDENTITY(A);
02700 COSV←COSD(DEG);
02800 SINV←SIND(DEG);
02900 CASE DATUM(AXIS) OF BEGIN
03000 BEGIN "X"
03100 A[2,2]←A[3,3]←COSV;
03200 A[3,2]←SINV;
03300 A[2,3]←-SINV
03400 END "X";
03500 BEGIN "Y"
03600 A[1,1]←A[3,3]←COSV;
03700 A[1,3]←SINV;
03800 A[3,1]←-SINV
03900 END "Y";
04000 BEGIN "Z"
04100 A[1,1]←A[2,2]←COSV;
04200 A[2,1]←SINV;
04300 A[1,2]←-SINV
04400 END "Z";
04500 END ;
04600 TIMES($ DATUM(CURRENT),A,$ DATUM(CURRENT));
04700 END "ROTATE";
04800 BEGIN "TRANSLATE"
04900 IF ¬(CURRENT IN INSTANCES) THEN BEGIN TYPE"NO INSTANCE SPECIFIED" STAR;GO TO D0 END;
05000 S←INPUT(FILE,LLINE);
05100 IDENTITY(A);
05200 FOR I←1 STEP 1 UNTIL 3 DO BEGIN
05300 DIST←REALSCAN(S,J);
05400 OUT(2,CVG(DIST));
05500 A[I,4]←DIST;
05600 END;
05700 TIMES($ DATUM(CURRENT),A,$ DATUM(CURRENT));
05800 OFS←21;
05900 GO TO LS;
06000 END"TRANSLATE";
06100 BEGIN "STRETCH"
06200 IF ¬(CURRENT IN INSTANCES) THEN BEGIN TYPE"NO INSTANCE SPECIFIED" STAR;GO TO D0 END;
06300 S←INPUT(FILE,LLINE);
06400 IDENTITY(A);
06500 FOR I←1 STEP 1 UNTIL 3 DO BEGIN
06600 DIST←REALSCAN(S,J);
06700 IF J=-1 THEN DONE;
06800 OUT(2,CVG(DIST));
06900 A[I,I]←DIST;
07000 END;
07100 TIMES($ DATUM(CURRENT),A,$ DATUM(CURRENT))
07200 END "STRETCH";
00100 BEGIN "DEFINE"
00200 LABEL DAN1,DAN2,DAN3,DAN4;
00300 DPYCLR;
00400 FIRSTIME←TRUE;
00500 FOOPED←PHI;
00600 P←GREAD;
00700 IF P IN PROTOTYPES THEN BEGIN TYPE"PROTOTYPE ALREADY EXISTS" STAR;GO TO D0 END;
00800 OFS←0;
00900 CURRENT←P;
01000 FOR I←1 STEP 1 UNTIL 20 DO VER[I]←REG[I]←NIL;
01100 L1: TYPE "WHICH REGION DO YOU WISH TO FOOP FIRST ?" LARROW;
01200 R←NREG;
01300 TYPE"REMEMBER TO GO AROUND THE FIRST FACE COUNTERCLOCKWISE,
01400 TYPE THE FIRST VERTEX" LARROW;
01500 $ MAKE FACE⊗P≡R;
01600 L6: PUT R IN FOOPED;
01700 LEDGES←($ BOUNDARY⊗R);
01800 IF LEDGES=PHI THEN BEGIN
01900 F←TA←NVER;
02000 L5: TYPE "TYPE NEXT NEIGHBOUR AND VERTEX " LARROW;
02100 N←NREG;
02200 IF N=NIL THEN GO TO TL1;
02300 H←NVER;
02400 IF H=NIL THEN GO TO TL1;
02500 E←GINTERNS(GENSYM(QE),0);
02600 $ MAKE VERTEX⊗P≡H;
02700 $ MAKE EDGE⊗P≡E;
02800 $ MAKE FACE⊗P≡N;
02900 $ MAKE BOUNDARY⊗R≡E;
03000 $ MAKE BOUNDARY⊗N≡E;
03100 $ MAKE CORNER⊗R≡H;
03200 $ MAKE CORNER⊗N≡H;
03300 $ MAKE CORNER⊗N≡TA;
03400 $ MAKE ENDPT⊗E≡H;
03500 $ MAKE ENDPT⊗E≡TA;
03600 GO TO L2 END;
03700 E←LOP(LEDGES);
03800 FOREACH H,TA,N| $ BOUNDARY ⊗N≡E ∧
03900 (N≠R) ∧
04000 $ ENDPT⊗E≡H ∧
04100 $ ENDPT⊗E≡TA ∧
04200 N⊗TA≡H DO F←TA;
04300 FOR I←1 STEP 1 UNTIL 20 DO IF VER[I]=TA THEN BEGIN TYPE "FIRST VERTEX "&CVS(I) EOM;DONE END;
04400 L4: BEGIN
04500 PN←PV←0;
04600 FOR I←1 STEP 1 UNTIL 20 DO
04700 BEGIN
04800 IF REG[I]=N THEN PN←I;
04900 IF VER[I]=H THEN PV←I;
05000 IF PN∧PV≠0 THEN DONE END;
05100 TYPE "NEXT NEIGHBOUR "&CVS(PN)&" NEXT VERTEX "&CVS(PV) EOM END;
05200 L2: MAKE R⊗H≡TA;
05300 IF H≠F THEN GO TO L3;
05400 IF (LEDGES←($ FACE⊗P)-FOOPED)=PHI THEN GO TO L0;
05500 FOR I←1 STEP 1 UNTIL 20 DO IF REG[I] IN LEDGES THEN BEGIN R←REG[I]; DONE END;
05600 TYPE "FOOP FOR FACE "&CVS(I)EOM;
05700 GO TO L6;
05800 L3: LT←TA;
05900 TA←H;
06000 FOREACH E,N,H | $ BOUNDARY⊗R≡E ∧
06100 $ ENDPT⊗E≡TA ∧
06200 $ ENDPT⊗E≡H ∧
06300 (H≠TA) ∧
06400 (H≠LT) ∧
06500 $ BOUNDARY⊗N≡E ∧
06600 (N≠R) DO GO TO L4;
06700 GO TO L5;
06800 L0: TYPE "INPUT VERTICES" LARROW;
06900 FOR I←1 STEP 1 UNTIL 20 DO
07000 BEGIN IF VER[I]=NIL THEN DONE;
07100 OUT(2,"
07200 ");
07300 TYPE CVS(I) LARROW;
07400 FOR J←1 STEP 1 UNTIL 3 DO BEGIN
07500 DEG←REALIN(FILE);
07600 $ DATUM(VER[I])[J]←DEG;
07700 OUT(2,CVG(DEG)) END;
07800 $ DATUM(VER[I])[4]←1.0 END;
07900 DAN1:
08000 FOREACH F|$ FACE⊗P≡F DO
08100 BEGIN SV[1]←SV[2]←SV[3]←0.0;SV[4]←1.0;
08200 FOREACH H,R,TA|F⊗H≡R ∧
08300 F⊗R≡TA DO BEGIN
08400 DIFFERENCE(TV1,$ DATUM(H),$ DATUM(R));
08500 DIFFERENCE(TV2,$ DATUM(R),$ DATUM(TA));
08600 CROSS(TTV,TV2,TV1);
08700 PLUS(SV,SV,TTV) END;
08800 MOVEV(PVV,$ DATUM(H));
08900 UNIT(TTV,SV);
09000 REDUCE(TTV);
09100 TTV[4]←-DOT(TTV,PVV);
09200 MOVEV($ DATUM(F),TTV);
09300 ERASE F⊗ANY≡ANY END;
09400 DAN2:
09500 FOREACH E| $ EDGE ⊗ P ≡ E DO
09600 FOREACH H,TA | $ ENDPT ⊗ E ≡ H ∧
09700 $ ENDPT ⊗ E ≡ TA ∧
09800 (H ≠ TA) DO
09900 BEGIN DIFFERENCE (TTV,$ DATUM(H),$ DATUM(TA));
10000 $ DATUM(E)←MAGNITUDE(TTV) ; DONE END;
10100 DAN3:
10200 FOREACH F,H | $ FACE⊗P≡F ∧
10300 $ CORNER⊗F≡H DO
10400 IF ABS(INNER($ DATUM(F),$ DATUM(H)))>1.0@-2 THEN
10500 BEGIN
10600 PN←PV←0;
10700 FOR I←1 STEP 1 UNTIL 20 DO
10800 BEGIN
10900 IF REG[I]=F THEN PN←I;
11000 IF VER[I]=H THEN PV←I;
11100 IF PN∧PV≠0 THEN DONE END;
11200 TYPE "WARNING POINT"&CVS(PV)&"NOT IN PLANE"&CVS(PN) EOM END;
11300 PUT P IN PROTOTYPES;
11400 $ MAKE PROTOTYPE⊗SCENE≡P;
11500 END "DEFINE";
00100 BEGIN "DONE"
00200 DPYCLR;
00300 RELEASE(5);
00400 CLOSE (2);
00500 LD1: TYPE "TYPE DUMP FILE NAME OR ""MODEL""" STAR;
00600 RF←INPUT(TTY,FIRST1);
00700 RF←INPUT(TTY,ID);
00800 IF EQU(RF,"MODEL") THEN
00900 BEGIN "WRITE OUT INITIALIZED GLOBAL MODEL"
01000 SAFE REAL ARRAY TRAN[1:1024];
01100 INTEGER I,J;
01200 TYPE "ENTER GLOBAL MODEL FILENAME" EOM;
01300 PUT_DATA(-1,CALL(0,"PJOB"),NULL); COMMENT THIS DELETES JOB NAME FROM SAVED SEG;
01400 RELEASE(2);
01500 OPEN (2,"DSK",'13,0,2,200,I,I);
01600 ENTER(2,INCHWL&".REL",I);
01700 DEFINE CALLI="'47000000000";
01800 START_CODE
01900 CALLI 1,'400022;
02000 TRO 1,'400000 ;
02100 MOVEM 1,I;
02200 END;
02300 FOR J←'400000 STEP 1024 UNTIL I DO
02400 BEGIN
02500 START_CODE
02600 HRL 1,J;
02700 HRR 1,TRAN;
02800 HRRZ 2,TRAN;
02900 BLT 1,1023(2);
03000 END;
03100 ARRYOUT(2,TRAN[1],1024);
03200 END;
03300 RELEASE (2);
03400 END "WRITE OUT INITIALIZED GLOBAL MODEL"
03500 ELSE BEGIN
03600 RF←RF&".TRP";
03700 LOOKUP(2,RF,EOF);
03800 IF EOF=0 THEN BEGIN TYPE"DUMP FILE NAME IN USE, DELETE Y OR N ?" STAR;
03900 S←INPUT(TTY,FIRST1);S←INPUT(TTY,ID);
04000 IF EQU (S,"Y") THEN CLOSE(2) ELSE GO TO LD1 END;
04100 ENTER(2,RF,EOF);
04200 FOREACH P|P IN PROTOTYPES DO OUT(2," "&PRINTNAME(P) EOM;
04300 OUT(2,"NIL"&'15&'12&'14);
04400 FOREACH P,E|P IN PROTOTYPES ∧
04500 $ EDGE ⊗ P ≡ E DO OUT(2," "&PRINTNAME(E)&" "&
04600 CVG($ DATUM(E)) EOM;
04700 OUT(2,"NIL"&'15&'12&'14);
04800 FOREACH P,H|P IN PROTOTYPES ∧
04900 $ VERTEX⊗P≡H DO
05000 BEGIN REDUCE($ DATUM(H));
05100 OUT(2," "&PRINTNAME(H)&" "&CVG($ DATUM(H)[1])&" "&
05200 CVG($ DATUM(H)[2])&" "&CVG($ DATUM(H)[3])&" "&CVG($ DATUM(H)[4]) EOM END;
05300 FOREACH P,H|P IN PROTOTYPES ∧
05400 $ FACE⊗P≡H DO
05500 OUT(2," "&PRINTNAME(H)&" "&CVG($ DATUM(H)[1])&" "&
05600 CVG($ DATUM(H)[2])&" "&CVG($ DATUM(H)[3])&" "&CVG($ DATUM(H)[4]) EOM ;
05700 OUT(2,"NIL"&'15&'12&'14);
05800 FOREACH INST | INST IN INSTANCES DO
05900 BEGIN OUT(2," "&PRINTNAME(INST) EOM;
06000 FOR I←1 STEP 1 UNTIL 4 DO
06100 BEGIN S←NULL;
06200 FOR J←1 STEP 1 UNTIL 4 DO
06300 S←S&" "&CVG($ DATUM(INST)[I,J]);
06400 OUT (2,S EOM END END;
06500 OUT(2,"NIL"&'15&'12&'14);
06600 FOREACH AT,OB,VAL | AT IN ATTRIBUTES ∧
06700 $ AT⊗OB≡VAL DO
06800 OUT(2," "&PRINTNAME(AT)&" ⊗ "&PRINTNAME(OB)
06900 &" ≡ "&PRINTNAME(VAL) EOM;
07000 OUT(2,"NIL");
07100 RELEASE (2);
07200 END;
07300 J←0;
07400 FOR I←0 STEP 1 UNTIL 255 DO
07500 IF HASHTAB[I]>0 THEN J←J+1;
07600 TYPE "SYMBOL TABLE "&CVG(100*J/I)&"% FULL" EOM;
07700 VAL←NEW;
07800 TYPE CVS(CVN(VAL))&" ITEMS USED" EOM;
07900 GO TO D1 END"DONE";
08000 BEGIN "SOURCE"
08100 IF FILE=4 THEN GO TO LS2;
08200 OPEN(4,"DSK",0,2,0,120,BREAK,EOF);
08300 LS1: S←INPUT(TTY,FIRST1);
08400 S←INPUT(TTY,ID);
08500 S←S&".REC";
08600 LOOKUP(4,S,EOF);
08700 IF EOF≠0 THEN BEGIN TYPE "FILE NOT FOUND" LARROW; GO TO LS1 END;
08800 FILE←4;
08900 DPYCLR;
09000 LS2: END"SOURCE";
09100 BEGIN"CLOSE"
09200 IF FILE=4 THEN GO TO LC2;
09300 CLOSE (5);
09400 CLOSE(2);
09500 LOOKUP(5,RF,EOF);
09600 ENTER(2,RF,EOF);
09700 LC1: S←INPUT(5,0);
09800 OUT(2,S);
09900 IF EOF=0 THEN GO TO LC1;
10000 LC2: END "CLOSE";
10100 BEGIN "PROTOTYPES" S←NULL;
10200 FOREACH OB |OB IN PROTOTYPES DO S←S&" "&PRINTNAME(OB);
10300 TYPE S EOM END "PROTOTYPES";
10400 BEGIN "DELETE"
10500 P←READ;
10600 IF ¬(P IN PROTOTYPES) THEN GO TO DE1;
10700 FOREACH INST|$ INSTANCE⊗P≡INST DO BEGIN
10800 REMOVE INST FROM INSTANCES;$ ERASE INSTANCE⊗P≡INST;GREMOB(INST) END;
10900 TL1: FOREACH OB|$ EDGE⊗P≡OB DO $ ERASE ENDPT⊗OB≡ANY;
11000 FOREACH OB|$ FACE⊗P≡OB DO BEGIN;
11100 $ ERASE CORNER⊗OB≡ANY;
11200 $ ERASE BOUNDARY⊗OB≡ANY END;
11300 LEDGES←($ EDGE⊗P)∪($ FACE⊗P)∪($ VERTEX⊗P);
11400 $ ERASE ANY⊗P≡ANY;
11500 FOREACH OB|OB IN LEDGES DO GREMOB (OB);
11600 REMOVE P FROM PROTOTYPES;
11700 GREMOB (P);
11800 DE1: IF (P IN INSTANCES)THEN BEGIN REMOVE P FROM INSTANCES;
11900 $ ERASE INSTANCE⊗ANY≡P;GREMOB (P) END;
12000 CURRENT←NIL; IF OFS≠0 THEN GO TO LS END "DELETE";
00100 BEGIN "PROTOTYPE"
00200 LABEL PL1;
00300 SAFE OWN REAL ARRAY INVT[1:4,1:4];
00400 INST←GREAD;
00500 IF (INST IN PROTOTYPES) THEN BEGIN CURRENT←INST; GO TO PL1 END;
00600 IF ¬(INST IN INSTANCES) THEN BEGIN TYPE PRINTNAME(INST)&" IS NOT AN INSTANCE" STAR;
00700 GO TO D0 END;
00800 FOREACH P| $ INSTANCE⊗P≡INST DO BEGIN
00900 MOVET(T,$ DATUM(INST));
01000 INVERSION(INV,T);
01100 FOR I ←1 STEP 1 UNTIL 4 DO
01200 FOR J←1 STEP 1 UNTIL 4 DO
01300 INVT[J,I]←INV[I,J];
01400 S←GETS;
01500 $ ERASE INSTANCE⊗P≡INST;
01600 REMOVE INST FROM INSTANCES;
01700 GREMOB(INST);
01800 INST←GINTERN(S);
01900 PUT INST IN PROTOTYPES;
02000 $ MAKE PROTOTYPE ⊗ SCENE ≡ INST;
02100 CURRENT←INST;
02200 FOREACH H|$ VERTEX⊗P≡H DO BEGIN
02300 TRANSFORM(TV1,T,$ DATUM(H));
02400 NH←GINTERNA(GENSYM(QV),TV1);
02500 $ MAKE VERTEX⊗INST≡NH;
02600 MAKE INST⊗H≡NH END;
02700 FOREACH E | $ EDGE⊗P≡E DO
02800 FOREACH H,TA,NH,NT | $ ENDPT⊗E≡H ∧
02900 $ ENDPT⊗E≡TA ∧
03000 (H≠TA) ∧
03100 INST⊗H≡NH ∧
03200 INST⊗TA≡NT DO BEGIN
03300 NE←GINTERNS(GENSYM(QE),0);
03400 $ MAKE EDGE⊗INST≡NE;
03500 MAKE INST⊗E≡NE;
03600 $ MAKE ENDPT⊗NE≡NH;
03700 $ MAKE ENDPT⊗NE≡NT ; DONE END;
03800 FOREACH R|$ FACE⊗P≡R DO BEGIN
03900 TRANSFORM(TV1,INVT,$ DATUM(R));
04000 NORMALIZE(TV1,TV1);
04100 NR←GINTERNA(GENSYM(QF),TV1);
04200 $ MAKE FACE⊗INST≡NR;
04300 FOREACH E,NE|$ BOUNDARY⊗R≡E ∧
04400 INST⊗E≡NE DO $ MAKE BOUNDARY⊗NR≡NE;
04500 FOREACH H,NH|$ CORNER⊗R≡H ∧
04600 INST⊗H≡NH DO $ MAKE CORNER⊗NR≡NH
04700 END ; ERASE INST⊗ANY≡ANY END;
04800 FOREACH E| $ EDGE ⊗ INST ≡ E DO
04900 FOREACH H,TA| $ ENDPT ⊗ E ≡ H ∧
05000 $ ENDPT ⊗ E ≡ TA ∧
05100 (H ≠ TA) DO
05200 BEGIN DIFFERENCE (TTV,$ DATUM(H),$ DATUM(TA));
05300 $ DATUM(E)←MAGNITUDE(TTV) ; DONE END;
05400 PL1: OFS←0;
05500 END"PROTOTYPE";
00100 BEGIN "TRANSFORM"
00200 EXTERNAL SIMPLE PROCEDURE TIMES (REFERENCE REAL R,A,B);
00300 IF ¬(CURRENT IN INSTANCES) THEN BEGIN TYPE"NO INSTANCE SPECIFIED" STAR;GO TO D0 END;
00400 FOR I←1 STEP 1 UNTIL 4 DO BEGIN
00500 S←NULL;
00600 FOR J←1 STEP 1 UNTIL 4 DO
00700 S←S&CVG($ DATUM(CURRENT)[I,J]);
00800 TYPE S EOM END
00900 END "TRANSFORM";
01000
01100 BEGIN "LSCENE"
01200 EXTERNAL SIMPLE PROCEDURE TIMES (REFERENCE REAL R,A,B);
01300 S←NULL;
01400 FOREACH OB | OB IN INSTANCES DO S←S&" "&PRINTNAME(OB);
01500 TYPE S EOM ;
01600 LS: IF CURRENT IN PROTOTYPES THEN CURRENT←NIL;
01700 OFS←21;
01800 END "LSCENE";
01900
02000 BEGIN "OBSERVER"
02100 EXTERNAL SIMPLE PROCEDURE IDENTITY(REFERENCE REAL R);
02200 EXTERNAL SIMPLE PROCEDURE TIMES(REFERENCE REAL R,A,B);
02300 OUT(2,"
02400 ");
02500 S←INPUT(FILE,LLINE);
02600 IDENTITY(PDATA[OFS+1]);
02700 QUERY(PDATA[OFS+ROLL],"ROLL");
02800 COSV←COSD(PDATA[OFS+ROLL]);
02900 SINV←SIND(PDATA[OFS+ROLL]);
03000 PDATA[OFS+6]←PDATA[OFS+11]←COSV;
03100 PDATA[OFS+10]←SINV;
03200 PDATA[OFS+7]←-SINV;
03300 QUERY(PDATA[OFS+PITCH],"PITCH");
03400 COSV←COSD(PDATA[OFS+PITCH]);
03500 SINV←SIND(PDATA[OFS+PITCH]);
03600 IDENTITY(PT1[1,1]);
03700 PT1[1,1]←PT1[3,3]←COSV;
03800 PT1[1,3]←SINV;
03900 PT1[3,1]←-SINV;
04000 TIMES(PDATA[OFS+1],PT1[1,1],PDATA[OFS+1]);
04100 QUERY(PDATA[OFS+YAW],"YAW");
04200 COSV←COSD(PDATA[OFS+YAW]);
04300 SINV←SIND(PDATA[OFS+YAW]);
04400 IDENTITY(PT1[1,1]);
04500 PT1[1,1]←PT1[2,2]←COSV;
04600 PT1[2,1]←SINV;
04700 PT1[1,2]←-SINV;
04800 TIMES(PDATA[OFS+1],PT1[1,1],PDATA[OFS+1]);
04900 QUERY(PDATA[OFS+DISTANCE],"DISTANCE");
05000 IDENTITY(PT1[1,1]);
05100 PT1[1,4]←-PDATA[OFS+DISTANCE];
05200 TIMES(PDATA[OFS+1],PT1[1,1],PDATA[OFS+1]);
05300 QUERY(PDATA[OFS+FOCUS],"FOCAL LENGTH");
05400 IDENTITY(PT1[1,1]);
05500 PT1[4,1]←1.0/PDATA[OFS+FOCUS];
05600 TIMES(PDATA[OFS+1],PT1[1,1],PDATA[OFS+1]);
05700 IDENTITY(PT1[1,1]);
05800 PT1[4,4]←0.01;
05900 TIMES(PDATA[OFS+1],PT1[1,1],PDATA[OFS+1]);
06000 IDENTITY(PT1[1,1]);
06100 IF OFS=0 THEN PT1[2,4]←100.0;
06200 TIMES(PDATA[OFS+1],PT1[1,1],PDATA[OFS+1]);
06300 IF OFS≠0 THEN GO TO LS;
06400 END "OBSERVER";
00100 BEGIN "MOVE"
00200 INST←GREAD;
00300 IF ¬(INST IN INSTANCES) THEN BEGIN TYPE"NO INSTANCE SPECIFIED" STAR;GO TO D0 END;
00400 ASSIGN P|$ INSTANCE⊗P≡INST HOLDS;
00500 IF ¬($ INSTANCE⊗P≡TEST_BLOCK) THEN BEGIN TYPE "NO WHERE TO GO" STAR;GO TO D0 END;
00600 ISSUE(7,"MODEL","HAND",MESSAGE START_TRAJECTORY("MODEL",0));
00700 ISSUE(7,"MODEL","MOVE",MESSAGE MOVE_INSTANCE(INST,$ DATUM(TEST_BLOCK),ZERO,ARM_PLAN));
00800 IF ARM_PLAN < 2 THEN BEGIN TYPE CVS(ARM_PLAN)&" SORRY" STAR;GO TO D0 END;
00900 ISSUE(5,"MODEL","HAND",MESSAGE PARK_ARM);
01000 ISSUE(7,"MODEL","HAND",MESSAGE CLOSE_TRAJECTORY);
01100 ISSUE(7,"MODEL","HAND",MESSAGE DO_IT("MODEL"));
01200 IF ARM_STATUS THEN TYPE CVOS(ARM_STATUS)&" SORRY" STAR;
01300 ARRTRAN($ DATUM(INST),$ DATUM(TEST_BLOCK));
01400 REMOVE TEST_BLOCK FROM INSTANCES;
01500 $ ERASE INSTANCE⊗P≡TEST_BLOCK;
01600 CURRENT←INST; IF OFS≠0 THEN GO TO LS
01700 END "MOVE";
01800
01900 BEGIN "PARK"
02000 ISSUE(5,"MODEL","HAND",MESSAGE START_TRAJECTORY("PARK",0));
02100 ISSUE(5,"MODEL","HAND",MESSAGE OPEN_HAND(3.0));
02200 ISSUE(5,"MODEL","HAND",MESSAGE PARK_ARM);
02300 ISSUE(7,"MODEL","HAND",MESSAGE CLOSE_TRAJECTORY);
02400 ISSUE(7,"MODEL","HAND",MESSAGE DO_IT("PARK"));
02500 IF ARM_STATUS THEN TYPE CVOS(ARM_STATUS)&" SORRY" STAR;
02600 END "PARK";
02700
02800 BEGIN "TWIST" REAL XS,YS,ZS;
02900 IF ¬(CURRENT IN INSTANCES) THEN BEGIN TYPE"NO INSTANCE SPECIFIED" STAR;GO TO D0 END;
03000 AXIS←READ;
03100 IF ¬(AXIS IN AXES) THEN BEGIN TYPE "MISSING ROTATION AXIS"STAR;GO TO D0 END;
03200 DEG←REALIN(FILE);
03300 OUT(2,CVG(DEG));
03400 IDENTITY(A);
03500 COSV←COSD(DEG);
03600 SINV←SIND(DEG);
03700 CASE DATUM(AXIS) OF BEGIN
03800 BEGIN "X"
03900 A[2,2]←A[3,3]←COSV;
04000 A[3,2]←SINV;
04100 A[2,3]←-SINV
04200 END "X";
04300 BEGIN "Y"
04400 A[1,1]←A[3,3]←COSV;
04500 A[1,3]←SINV;
04600 A[3,1]←-SINV
04700 END "Y";
04800 BEGIN "Z"
04900 A[1,1]←A[2,2]←COSV;
05000 A[2,1]←SINV;
05100 A[1,2]←-SINV
05200 END "Z";
05300 END ;
05400 XS←$ DATUM(CURRENT)[1,4];$ DATUM(CURRENT)[1,4]←0.0;
05500 YS←$ DATUM(CURRENT)[2,4];$ DATUM(CURRENT)[2,4]←0.0;
05600 ZS←$ DATUM(CURRENT)[3,4];$ DATUM(CURRENT)[3,4]←0.0;
05700 TIMES($ DATUM(CURRENT),A,$ DATUM(CURRENT));
05800 $ DATUM(CURRENT)[1,4]←XS;
05900 $ DATUM(CURRENT)[2,4]←YS;
06000 $ DATUM(CURRENT)[3,4]←ZS;
06100 END "TWIST";
00100 END;
00200 OUT(2,"
00300 ");
00400 IF CURRENT=NIL ∧ OFS=0 THEN GO TO D0 ;
00500 TYPLOC(-300,-475);
00600 IF CURRENT IN PROTOTYPES THEN BEGIN
00700 DPYSET(PDAT);
00800 DPYBRT(3);
00900 AXISOUT;
01000 MOVET(T,PDATA);
01100 DISP(CURRENT,T,PRINTNAME(CURRENT));
01200 HYDPOG(SDISP);
01300 DPYOUT(PDISP);
01400 END
01500 ELSE BEGIN DPYSET(SDAT);
01600 IF OFS=0 THEN BEGIN DPYBRT(3); AXISOUT END ELSE DPYBRT(5);
01700 BEGIN EXTERNAL SIMPLE PROCEDURE TIMES(REFERENCE REAL R,A,B);
01800 TIMES(PTT[1,1],PDATA[OFS+1],$ DATUM(CURRENT)[1,1]);
01900 END;
02000 FOREACH P|$ INSTANCE⊗P≡CURRENT DO DISP(P,PTT,PRINTNAME(CURRENT));
02300 IF OFS=21 THEN BEGIN
02400 EXTERNAL SIMPLE PROCEDURE TIMES(REFERENCE REAL R,A,B);
02600 DPYBRT(3);
02700 AXISOUT;
02800 LSCENE←INSTANCES;
02900 IF CURRENT IN INSTANCES THEN REMOVE CURRENT FROM LSCENE;
03000 FOREACH P,H|H IN LSCENE ∧ $ INSTANCE ⊗P≡H DO BEGIN
03100 TIMES(PTT[1,1],PDATA[22],$ DATUM(H)[1,1]);
03200 DISP(P,PTT,PRINTNAME(H)) END;
03400 END;
03410 HYDPOG(PDISP);
03455 DPYOUT(SDISP);
03500 END;
03600 OUT(TTY,"*
03700 ");
03800 GO TO D0;
03900 D1: END;